Centralidad en redes

Datos

En este ejemplos consideramos la red de aeropuertos de EU:

library(tidyverse)
library(tidygraph)
library(ggraph)
library(igraphdata)
data("USairports")
# ver detalles
# ?USairports

Nota que cada arista corresponde a una aerolínea (carrier) y tipo de avión (Aircraft), y los nodos son los aeropuertos. Los datos de las aristas corresponden a vuelos de Diciembre de 2010, y es una gráfica dirigida.

Sobre los datos:

Vertex attributes	Description
name	Symbolic vertex name, this is the three letter IATA airport code.
City	City and state, where the airport is located.
Position	Position of the airport, in WGS coordinates.

Edge attributes	Description
Carrier	Name of the airline. The network includes both domestic and international carriers that performed at least one flight in December of 2010.
Departures	The number of departures (for a given airline and aircraft type.
Seats	The total number of seats available on the flights carried out by a given airline, using a given aircraft type.
Passengers	The total number of passangers on the flights carried out by a given airline, using a given aircraft type.
Aircraft	Type of the aircraft.
Distance	The distance between the two airports, in miles.

airports <- USairports %>% as_tbl_graph()
airports

# A tbl_graph: 755 nodes and 23473 edges
#
# A directed multigraph with 6 components
#
# Node Data: 755 x 3 (active)
  name  City          Position        
  <chr> <chr>         <chr>           
1 BGR   Bangor, ME    N444827 W0684941
2 BOS   Boston, MA    N422152 W0710019
3 ANC   Anchorage, AK N611028 W1495947
4 JFK   New York, NY  N403823 W0734644
5 LAS   Las Vegas, NV N360449 W1150908
6 MIA   Miami, FL     N254736 W0801726
# … with 749 more rows
#
# Edge Data: 23,473 x 8
   from    to Carrier  Departures Seats Passengers Aircraft Distance
  <int> <int> <chr>         <dbl> <dbl>      <dbl>    <int>    <dbl>
1     1     4 British…          1   226        193      627      382
2     1     4 British…          1   299        253      819      382
3     2     7 British…          1   216        141      627      200
# … with 2.347e+04 more rows

En total son 755 aeropuertos y 23,473 tipos aerolíneas y tipos de aviones.

Esta gŕafica es un multigrafo (puede haber varias aristas con la misma dirección en un par de nodos).

Nos interesa en primer lugar agregar a un grafo, y considerar el total de pasajeros (puedes también considerar número de asientos, por ejemplo) que viajó entre cada par de aeropuertos. Podemos agregar de las siguiente forma:

# seleccionamos solo pasajeros
vertices <- airports %>% 
  activate(edges) %>% 
  select(to, from, Passengers) %>% as_tibble()
# agregar
vertices_agregados <- vertices %>% 
  group_by(to, from) %>% 
  summarise(pax = sum(Passengers))
# nodos, y agregar estado
nodos <- airports %>% activate(nodes) %>% 
  as_tibble() %>% 
  separate(City, into = c('ciudad_nombre', 'estado'), sep = ', ')
# construir nueva red
aeropuertos <- tbl_graph(nodes = nodos, edges = vertices_agregados) 
aeropuertos 

# A tbl_graph: 755 nodes and 8265 edges
#
# A directed multigraph with 6 components
#
# Node Data: 755 x 4 (active)
  name  ciudad_nombre estado Position        
  <chr> <chr>         <chr>  <chr>           
1 BGR   Bangor        ME     N444827 W0684941
2 BOS   Boston        MA     N422152 W0710019
3 ANC   Anchorage     AK     N611028 W1495947
4 JFK   New York      NY     N403823 W0734644
5 LAS   Las Vegas     NV     N360449 W1150908
6 MIA   Miami         FL     N254736 W0801726
# … with 749 more rows
#
# Edge Data: 8,265 x 3
   from    to   pax
  <int> <int> <dbl>
1     2     1     2
2     4     1    35
3     6     1     3
# … with 8,262 more rows

# seleccionamos solo asientos
vertices <- airports %>% 
  activate(edges) %>% 
  select(to, from, Seats) %>% as_tibble()
# agregar
vertices_agregados <- vertices %>% 
  group_by(to, from) %>% 
  summarise(pax = sum(Seats))
# nodos, y agregar estado
nodos <- airports %>% activate(nodes) %>% 
  as_tibble() %>% 
  separate(City, into = c('ciudad_nombre', 'estado'), sep = ', ')
# construir nueva red
aeropuertos <- tbl_graph(nodes = nodos, edges = vertices_agregados) 
aeropuertos 

# A tbl_graph: 755 nodes and 8265 edges
#
# A directed multigraph with 6 components
#
# Node Data: 755 x 4 (active)
  name  ciudad_nombre estado Position        
  <chr> <chr>         <chr>  <chr>           
1 BGR   Bangor        ME     N444827 W0684941
2 BOS   Boston        MA     N422152 W0710019
3 ANC   Anchorage     AK     N611028 W1495947
4 JFK   New York      NY     N403823 W0734644
5 LAS   Las Vegas     NV     N360449 W1150908
6 MIA   Miami         FL     N254736 W0801726
# … with 749 more rows
#
# Edge Data: 8,265 x 3
   from    to   pax
  <int> <int> <dbl>
1     2     1    34
2     4     1    50
3     6     1    12
# … with 8,262 more rows

Filtro de conexiones débiles

Podemos también filtrar opcionalmente aquellas conexiones que tengan un número de pasajeros bajo durante el mes de observación. La distribución de pasajeros podemos examinarla con:

pasajeros <- aeropuertos %>% activate(edges) %>% 
  select(from, to , pax)
quantile(pull(pasajeros, pax), seq(0, 1, 0.1))

      0%      10%      20%      30%      40%      50%      60% 
     1.0     13.0     50.0    142.0    862.2   1856.0   3343.4 
     70%      80%      90%     100% 
  5273.8   8948.2  18117.2 142839.0 

corte_pax <- 100
aero_grandes <- aeropuertos %>% activate(edges) %>% 
  filter(pax > corte_pax) %>% 
  activate(nodes) %>% 
  filter(!node_is_isolated()) #eliminar nodos que quedan sin conexiones

Haz una primera gráfica (checa también como colorear según una variable de nodos):

aero_grandes %>% 
    activate(nodes) %>% 
    mutate(color_ca = ifelse(estado == "CA", "CA", "Otros")) %>% 
    ggraph(layout = 'fr', niter = 2000) + 
    geom_edge_link(arrow = arrow(length = unit(2, 'mm')), alpha = 0.1, colour="gray") + 
    geom_node_point(aes(colour = color_ca)) +
    theme_graph()

Pregunta 1: cuántas componentes tiene esta gráfica (tip: haz un mutate con la función group_components)

Esta gráfica cuenta con 8 componentes.

aero_grandes %>%
  activate(nodes) %>%
  mutate(group = group_components())

# A tbl_graph: 575 nodes and 6174 edges
#
# A directed multigraph with 8 components
#
# Node Data: 575 x 5 (active)
  name  ciudad_nombre estado Position         group
  <chr> <chr>         <chr>  <chr>            <int>
1 BGR   Bangor        ME     N444827 W0684941     1
2 BOS   Boston        MA     N422152 W0710019     1
3 ANC   Anchorage     AK     N611028 W1495947     1
4 JFK   New York      NY     N403823 W0734644     1
5 LAS   Las Vegas     NV     N360449 W1150908     1
6 MIA   Miami         FL     N254736 W0801726     1
# … with 569 more rows
#
# Edge Data: 6,174 x 3
   from    to   pax
  <int> <int> <dbl>
1    41     1   122
2    42     1  2176
3    55     1  3935
# … with 6,171 more rows

aero_grandes

# A tbl_graph: 575 nodes and 6174 edges
#
# A directed multigraph with 8 components
#
# Node Data: 575 x 4 (active)
  name  ciudad_nombre estado Position        
  <chr> <chr>         <chr>  <chr>           
1 BGR   Bangor        ME     N444827 W0684941
2 BOS   Boston        MA     N422152 W0710019
3 ANC   Anchorage     AK     N611028 W1495947
4 JFK   New York      NY     N403823 W0734644
5 LAS   Las Vegas     NV     N360449 W1150908
6 MIA   Miami         FL     N254736 W0801726
# … with 569 more rows
#
# Edge Data: 6,174 x 3
   from    to   pax
  <int> <int> <dbl>
1    41     1   122
2    42     1  2176
3    55     1  3935
# … with 6,171 more rows

Return value of group_component: a numeric vector with the membership for each node in the graph. The enumeration happens in order based on group size progressing from the largest to the smallest group

Pregunta 2: prueba otro layout: kk o graphopt, por ejemplo. ¿Puedes reconocer estructuras distintas? ¿Qué método parece funcionar mejor?

aero_grandes %>% 
    activate(nodes) %>% 
    #mutate(color_ca = ifelse(estado == "LA", "LA", "Otros")) %>% 
    ggraph(layout = 'kk') + 
    geom_edge_link(arrow = arrow(length = unit(2, 'mm')), alpha = 0.1, colour="gray") + 
    geom_node_point(aes(colour =estado)) +
    theme_graph()

aero_grandes %>% 
    activate(nodes) %>% 
    mutate(color_ca = ifelse(estado == "CA", "CA", "Otros")) %>% 
    ggraph(layout = 'graphopt') + 
    geom_edge_link(arrow = arrow(length = unit(2, 'mm')), alpha = 0.1, colour="gray") + 
    geom_node_point(aes(colour = color_ca)) +
    theme_graph()

Extraer componente grande

Filtra la componente conexa más grande:

aero <- aero_grandes %>% 
    activate(nodes) %>% 
    mutate(component = group_components()) %>%
    filter(component == 1)

Intermediación

Calcula intermediación:

aero <- aero %>% activate(nodes) %>% 
  mutate(intermediacion = centrality_betweenness())
aero

# A tbl_graph: 558 nodes and 6151 edges
#
# A directed multigraph with 1 component
#
# Node Data: 558 x 6 (active)
  name  ciudad_nombre estado Position         component intermediacion
  <chr> <chr>         <chr>  <chr>                <int>          <dbl>
1 BGR   Bangor        ME     N444827 W0684941         1           35.0
2 BOS   Boston        MA     N422152 W0710019         1        14605. 
3 ANC   Anchorage     AK     N611028 W1495947         1        86686. 
4 JFK   New York      NY     N403823 W0734644         1         9464. 
5 LAS   Las Vegas     NV     N360449 W1150908         1        13065. 
6 MIA   Miami         FL     N254736 W0801726         1         2847. 
# … with 552 more rows
#
# Edge Data: 6,151 x 3
   from    to   pax
  <int> <int> <dbl>
1    41     1   122
2    42     1  2176
3    55     1  3935
# … with 6,148 more rows

Pregunta 3: ¿cuáles son los aeropuertos con intermediación más grande? (convierte el objeto de la gráfica a tibble después de activar nodos).

Ciudad	Estado	Intermediación
Anchorage	AK-Alaska	86686
Denver	CO-Colorado	35444
Minneapolis	MN- Minnesota	33674
Bethel	AK-Alaska	31412
Seattle	WA-Washington	30286

Ahora haz una gráfica coloreando con un estado relevante (considera tu respuesta de la pregunta anterior) y usando la intermediación como tamaño:

aero %>%
    activate(nodes) %>% 
    mutate(color_edo = ifelse(estado == "AK", "AK", "Otros")) %>% 
    ggraph(layout = 'fr', niter=2000) + 
    geom_edge_link(arrow = arrow(length = unit(2, 'mm')), alpha = 0.1, colour="gray") + 
    geom_node_point(aes(size = intermediacion, colour=color_edo)) +
    theme_graph()

Pregunta 4 Explica el nodo con mayor intermediación de la gráfica. ¿Qué conecta?

Conecta Alaska con el resto de los Estados.

Centralidad de eigenvector

Calcula centralidad de eigenvector, y ahora usa tamaño para esta centralidad y color para intermediación

aero<- aero %>%
    activate(nodes) %>% 
    mutate(central_eigen = centrality_eigen())

aero %>%
    activate(nodes) %>% 
    mutate(central_eigen = centrality_eigen()) %>%
    as_tibble() %>%
    arrange(desc(central_eigen))%>%
    head()

Pregunta 5 ¿Cuáles son los aeropuertos con mayor centralidad de eigenvector? Contrasta con intermediación.

ciudad_nombre	estado	intermediacion	central_eigen
Atlanta	GA-Georgia	26290.09	1.0000000
Chicago	IL-Illinois	29361.47	0.9840030
Dallas/Ft.Worth	TX-Texas	20743.55	0.9230075
Denver	CO-Colorado	35444.43	0.9131323
Minneapolis	MN-Minnesota	33673.76	0.9082336
Detroit	MI-Michigan	17181.70	0.8987680

Examinar centralidad

Elimina los aeropuertos de Alaska y vuelve a graficar, esta vez usando centralidad de eigenvector para color y tamaño.

aero %>%
  activate(nodes) %>% 
  filter(estado!="AK") %>% 
ggraph(layout = 'graphopt', spring.constant = 0.25, charge = 0.05, niter = 300) + 
  geom_edge_link2(arrow = arrow(length = unit(2, 'mm')), alpha = 0.01, colour="black") + 
  geom_node_point(aes(size = central_eigen, colour=central_eigen)) +
  theme_graph() 

Pregunta 6: ¿calcular centralidad y luego filtrar nodos es lo mismo que filtrar nodos y luego calcular centralidad?

No. Falta desarrollar por qué.

Pregunta 7: experimenta con los parámetros del layout (por ejemplo, los 2 que se usan arriba). ¿Cómo obtienes mejores resultados?

aero %>%
  activate(nodes) %>% 
  filter(estado!="AK") %>% 
ggraph(layout = 'graphopt', spring.constant = 0.95, charge = 0.05, niter = 300) + 
  geom_edge_link2(arrow = arrow(length = unit(2, 'mm')), alpha = 0.01, colour="black") + 
  geom_node_point(aes(size = central_eigen, colour=central_eigen)) +
  theme_graph() 

aero %>%
  activate(nodes) %>% 
  filter(estado!="AK") %>% 
ggraph(layout = 'graphopt', spring.constant = 0.25, charge = 0.95, niter = 300) + 
  geom_edge_link2(arrow = arrow(length = unit(2, 'mm')), alpha = 0.01, colour="black") + 
  geom_node_point(aes(size = central_eigen, colour=central_eigen)) +
  theme_graph() 

aero %>%
  activate(nodes) %>% 
  filter(estado!="AK") %>% 
ggraph(layout = 'graphopt', spring.constant = 0.5, charge = 0.5, niter = 300) + 
  geom_edge_link2(arrow = arrow(length = unit(2, 'mm')), alpha = 0.01, colour="black") + 
  geom_node_point(aes(size = central_eigen, colour=central_eigen)) +
  theme_graph() 

Pregunta 8 (más difícil): etiqueta los nodos. Etiqueta solo los nodos que tengan centralidad de eigenvector alta. Puedes experimentar (layout, colores, tamaño de texto) con este código:

aero %>%
  activate(nodes) %>% 
  filter(estado!="AK") %>% 
ggraph(layout = 'graphopt', spring.constant = 0.25, charge = 0.05, niter = 300) + 
  geom_edge_link2(arrow = arrow(length = unit(2, 'mm')), alpha = 0.01, colour="black") + 
  geom_node_point(aes(size = central_eigen, colour=central_eigen)) +
  geom_node_text(aes(label = name, alpha = central_eigen>0.8987679), repel = TRUE, size = 3, color = "black") +
  theme_graph()